home *** CD-ROM | disk | FTP | other *** search
/ Ham Radio 2000 / Ham Radio 2000.iso / ham2000 / misc / dspice0s / card.c < prev    next >
C/C++ Source or Header  |  1992-11-21  |  26KB  |  1,017 lines
  1. /* card.f -- translated by f2c (version of 3 February 1990  3:36:42).
  2.    You must link the resulting object file with the libraries:
  3.     -lF77 -lI77 -lm -lc   (in that order)
  4. */
  5.  
  6. #include "f2c.h"
  7.  
  8. /* Common Block Declarations */
  9.  
  10. struct {
  11.     integer ielmnt, isbckt, nsbckt, iunsat, nunsat, itemps, numtem, isens, 
  12.         nsens, ifour, nfour, ifield, icode, idelim, icolum, insize, 
  13.         junode, lsbkpt, numbkp, iorder, jmnode, iur, iuc, ilc, ilr, 
  14.         numoff, isr, nmoffc, iseq, iseq1, neqn, nodevs, ndiag, iswap, 
  15.         iequa, macins, lvnim1, lx0, lvn, lynl, lyu, lyl, lx1, lx2, lx3, 
  16.         lx4, lx5, lx6, lx7, ld0, ld1, ltd, imynl, imvn, lcvn, nsnod, 
  17.         nsmat, nsval, icnod, icmat, icval, loutpt, lpol, lzer, irswpf, 
  18.         irswpr, icswpf, icswpr, irpt, jcpt, irowno, jcolno, nttbr, nttar, 
  19.         lvntmp;
  20. } tabinf_;
  21.  
  22. #define tabinf_1 tabinf_
  23.  
  24. struct {
  25.     doublereal omega, time, delta, delold[7], ag[7], vt, xni, egfet, xmu, 
  26.         sfactr;
  27.     integer mode, modedc, icalc, initf, method, iord, maxord, noncon, iterno, 
  28.         itemno, nosolv, modac, ipiv, ivmflg, ipostp, iscrch, iofile;
  29. } status_;
  30.  
  31. #define status_1 status_
  32.  
  33. struct {
  34.     doublereal atime, aprog[3], adate, atitle[10], defl, defw, defad, defas, 
  35.         rstats[50];
  36.     integer iwidth, lwidth, nopage;
  37. } miscel_;
  38.  
  39. #define miscel_1 miscel_
  40.  
  41. struct {
  42.     doublereal achar, afield[15], oldlin[15];
  43.     integer kntrc, kntlim;
  44. } line_;
  45.  
  46. #define line_1 line_
  47.  
  48. struct {
  49.     integer iprnta, iprntl, iprntm, iprntn, iprnto, limtim, limpts, lvlcod, 
  50.         lvltim, itl1, itl2, itl3, itl4, itl5, itl6, igoof, nogo, keof;
  51. } flags_;
  52.  
  53. #define flags_1 flags_
  54.  
  55. struct {
  56.     doublereal twopi, xlog2, xlog10, root2, rad, boltz, charge, ctok, gmin, 
  57.         reltol, abstol, vntol, trtol, chgtol, eps0, epssil, epsox, pivtol,
  58.          pivrel;
  59. } knstnt_;
  60.  
  61. #define knstnt_1 knstnt_
  62.  
  63. struct {
  64.     doublereal value[200000];
  65. } blank_;
  66.  
  67. #define blank_1 blank_
  68.  
  69. /* Table of constant values */
  70.  
  71. static integer c__1 = 1;
  72. static integer c__0 = 0;
  73. static integer c__50 = 50;
  74.  
  75. /*<       subroutine card >*/
  76. /* Subroutine */ int card_()
  77. {
  78.     /* Initialized data */
  79.  
  80.     static struct {
  81.     char e_1[8];
  82.     doublereal e_2;
  83.     } equiv_41 = { {'k', ' ', ' ', ' ', ' ', ' ', ' ', ' '}, 0. };
  84.  
  85. #define ak (*(doublereal *)&equiv_41)
  86.  
  87.     static struct {
  88.     char e_1[8];
  89.     doublereal e_2;
  90.     } equiv_42 = { {'u', ' ', ' ', ' ', ' ', ' ', ' ', ' '}, 0. };
  91.  
  92. #define au (*(doublereal *)&equiv_42)
  93.  
  94.     static struct {
  95.     char e_1[8];
  96.     doublereal e_2;
  97.     } equiv_43 = { {'n', ' ', ' ', ' ', ' ', ' ', ' ', ' '}, 0. };
  98.  
  99. #define an (*(doublereal *)&equiv_43)
  100.  
  101.     static struct {
  102.     char e_1[8];
  103.     doublereal e_2;
  104.     } equiv_44 = { {'p', ' ', ' ', ' ', ' ', ' ', ' ', ' '}, 0. };
  105.  
  106. #define ap (*(doublereal *)&equiv_44)
  107.  
  108.     static struct {
  109.     char e_1[8];
  110.     doublereal e_2;
  111.     } equiv_45 = { {'e', ' ', ' ', ' ', ' ', ' ', ' ', ' '}, 0. };
  112.  
  113. #define ae (*(doublereal *)&equiv_45)
  114.  
  115.     static struct {
  116.     char e_1[8];
  117.     doublereal e_2;
  118.     } equiv_46 = { {'m', ' ', ' ', ' ', ' ', ' ', ' ', ' '}, 0. };
  119.  
  120. #define am (*(doublereal *)&equiv_46)
  121.  
  122.     static struct {
  123.     char e_1[8];
  124.     doublereal e_2;
  125.     } equiv_47 = { {'f', ' ', ' ', ' ', ' ', ' ', ' ', ' '}, 0. };
  126.  
  127. #define af (*(doublereal *)&equiv_47)
  128.  
  129.     static struct {
  130.     char e_1[8];
  131.     doublereal e_2;
  132.     } equiv_48 = { {'t', ' ', ' ', ' ', ' ', ' ', ' ', ' '}, 0. };
  133.  
  134. #define at (*(doublereal *)&equiv_48)
  135.  
  136.     static struct {
  137.     char e_1[8];
  138.     doublereal e_2;
  139.     } equiv_49 = { {'i', ' ', ' ', ' ', ' ', ' ', ' ', ' '}, 0. };
  140.  
  141. #define ai (*(doublereal *)&equiv_49)
  142.  
  143.     static struct {
  144.     char e_1[8];
  145.     doublereal e_2;
  146.     } equiv_50 = { {'(', ' ', ' ', ' ', ' ', ' ', ' ', ' '}, 0. };
  147.  
  148. #define alprn (*(doublereal *)&equiv_50)
  149.  
  150.     static struct {
  151.     char e_1[8];
  152.     doublereal e_2;
  153.     } equiv_51 = { {')', ' ', ' ', ' ', ' ', ' ', ' ', ' '}, 0. };
  154.  
  155. #define arprn (*(doublereal *)&equiv_51)
  156.  
  157.     static struct {
  158.     char e_1[8];
  159.     doublereal e_2;
  160.     } equiv_52 = { {'=', ' ', ' ', ' ', ' ', ' ', ' ', ' '}, 0. };
  161.  
  162. #define aequal (*(doublereal *)&equiv_52)
  163.  
  164.     static struct {
  165.     char e_1[8];
  166.     doublereal e_2;
  167.     } equiv_53 = { {'.', 'e', 'n', 'd', ' ', ' ', ' ', ' '}, 0. };
  168.  
  169. #define aend (*(doublereal *)&equiv_53)
  170.  
  171.     static struct {
  172.     char e_1[80];
  173.     doublereal e_2;
  174.     } equiv_54 = { {'0', ' ', ' ', ' ', ' ', ' ', ' ', ' ', '1', ' ', ' ',
  175.          ' ', ' ', ' ', ' ', ' ', '2', ' ', ' ', ' ', ' ', ' ', ' ', 
  176.         ' ', '3', ' ', ' ', ' ', ' ', ' ', ' ', ' ', '4', ' ', ' ', 
  177.         ' ', ' ', ' ', ' ', ' ', '5', ' ', ' ', ' ', ' ', ' ', ' ', 
  178.         ' ', '6', ' ', ' ', ' ', ' ', ' ', ' ', ' ', '7', ' ', ' ', 
  179.         ' ', ' ', ' ', ' ', ' ', '8', ' ', ' ', ' ', ' ', ' ', ' ', 
  180.         ' ', '9', ' ', ' ', ' ', ' ', ' ', ' ', ' '}, 0. };
  181.  
  182. #define adigit ((doublereal *)&equiv_54)
  183.  
  184.     static struct {
  185.     char e_1[8];
  186.     doublereal e_2;
  187.     } equiv_55 = { {' ', ' ', ' ', ' ', ' ', ' ', ' ', ' '}, 0. };
  188.  
  189. #define ablnk (*(doublereal *)&equiv_55)
  190.  
  191.     static struct {
  192.     char e_1[8];
  193.     doublereal e_2;
  194.     } equiv_56 = { {'.', ' ', ' ', ' ', ' ', ' ', ' ', ' '}, 0. };
  195.  
  196. #define aper (*(doublereal *)&equiv_56)
  197.  
  198.     static struct {
  199.     char e_1[8];
  200.     doublereal e_2;
  201.     } equiv_57 = { {'+', ' ', ' ', ' ', ' ', ' ', ' ', ' '}, 0. };
  202.  
  203. #define aplus (*(doublereal *)&equiv_57)
  204.  
  205.     static struct {
  206.     char e_1[8];
  207.     doublereal e_2;
  208.     } equiv_58 = { {'-', ' ', ' ', ' ', ' ', ' ', ' ', ' '}, 0. };
  209.  
  210. #define aminus (*(doublereal *)&equiv_58)
  211.  
  212.     static struct {
  213.     char e_1[8];
  214.     doublereal e_2;
  215.     } equiv_59 = { {'*', ' ', ' ', ' ', ' ', ' ', ' ', ' '}, 0. };
  216.  
  217. #define astk (*(doublereal *)&equiv_59)
  218.  
  219.     static struct {
  220.     char e_1[8];
  221.     doublereal e_2;
  222.     } equiv_60 = { {'g', ' ', ' ', ' ', ' ', ' ', ' ', ' '}, 0. };
  223.  
  224. #define bg (*(doublereal *)&equiv_60)
  225.  
  226.  
  227.     /* Format strings */
  228.     static char fmt_16[] = "(\0020*error*:  .end card missing\002/)";
  229.     static char fmt_31[] = "(1x)";
  230.     static char fmt_41[] = "(1x,10a8)";
  231.     static char fmt_501[] = "(\0020*error*:  illegal number -- scan stopped \
  232. at column \002,i3/)";
  233.  
  234.     /* System generated locals */
  235.     integer i_1;
  236.  
  237.     /* Builtin functions */
  238.     integer s_wsfe(), e_wsfe(), do_fio();
  239.     double exp(), d_sign();
  240.  
  241.     /* Local variables */
  242.     static integer idec;
  243.     static doublereal anam;
  244.     static integer kchr, iexp;
  245.     extern /* Subroutine */ int move_();
  246.     static integer i, nofld, isign, itemp;
  247.     static doublereal xsign, xmant;
  248.     static integer jdelim;
  249. #define nodplc ((integer *)&blank_1)
  250. #define cvalue ((complex *)&blank_1)
  251.     static integer numfld;
  252.     extern /* Subroutine */ int getlin_();
  253.     extern integer nxtchr_();
  254.     extern /* Subroutine */ int extmem_();
  255.  
  256.     /* Fortran I/O blocks */
  257.     static cilist io__25 = { 0, 0, 0, fmt_16, 0 };
  258.     static cilist io__26 = { 0, 0, 0, fmt_31, 0 };
  259.     static cilist io__27 = { 0, 0, 0, fmt_41, 0 };
  260.     static cilist io__38 = { 0, 0, 0, fmt_501, 0 };
  261.     static cilist io__39 = { 0, 0, 0, fmt_41, 0 };
  262.     static cilist io__40 = { 0, 0, 0, fmt_41, 0 };
  263.  
  264.  
  265. /*<       implicit double precision (a-h,o-z) >*/
  266.  
  267. /*     this routine scans the input lines, storing each field into the */
  268. /* tables ifield, idelim, icolum, and icode.  with the exception of the */
  269.  
  270. /* '.end' line, card always reads the next line to check for a possible */
  271.  
  272. /* continuation before it exits. */
  273.  
  274. /* spice version 2g.6  sccsid=tabinf 3/15/83 */
  275. /*<       common /tabinf/ ielmnt,isbckt,nsbckt,iunsat,nunsat,itemps,numtem, >*/
  276. /*<      1   isens,nsens,ifour,nfour,ifield,icode,idelim,icolum,insize, >*/
  277. /*<      2   junode,lsbkpt,numbkp,iorder,jmnode,iur,iuc,ilc,ilr,numoff,isr, >*/
  278. /*<      3   nmoffc,iseq,iseq1,neqn,nodevs,ndiag,iswap,iequa,macins,lvnim1, >*/
  279. /*<      4   lx0,lvn,lynl,lyu,lyl,lx1,lx2,lx3,lx4,lx5,lx6,lx7,ld0,ld1,ltd, >*/
  280. /*<      5   imynl,imvn,lcvn,nsnod,nsmat,nsval,icnod,icmat,icval, >*/
  281. /*<      6   loutpt,lpol,lzer,irswpf,irswpr,icswpf,icswpr,irpt,jcpt, >*/
  282. /*<      7   irowno,jcolno,nttbr,nttar,lvntmp >*/
  283. /* spice version 2g.6  sccsid=status 3/15/83 */
  284. /*<       common /status/ omega,time,delta,delold(7),ag(7),vt,xni,egfet, >*/
  285. /*<      1   xmu,sfactr,mode,modedc,icalc,initf,method,iord,maxord,noncon, >*/
  286. /*<      2   iterno,itemno,nosolv,modac,ipiv,ivmflg,ipostp,iscrch,iofile >*/
  287. /* spice version 2g.6  sccsid=miscel 3/15/83 */
  288. /*<       common /miscel/ atime,aprog(3),adate,atitle(10),defl,defw,defad, >*/
  289. /*<      1  defas,rstats(50),iwidth,lwidth,nopage >*/
  290. /* spice version 2g.6  sccsid=line 3/15/83 */
  291. /*<       common /line/ achar,afield(15),oldlin(15),kntrc,kntlim >*/
  292. /* spice version 2g.6  sccsid=flags 3/15/83 */
  293. /*<       common /flags/ iprnta,iprntl,iprntm,iprntn,iprnto,limtim,limpts, >*/
  294. /*<      1   lvlcod,lvltim,itl1,itl2,itl3,itl4,itl5,itl6,igoof,nogo,keof >*/
  295. /* spice version 2g.6  sccsid=knstnt 3/15/83 */
  296. /*<       common /knstnt/ twopi,xlog2,xlog10,root2,rad,boltz,charge,ctok, >*/
  297. /*<      1   gmin,reltol,abstol,vntol,trtol,chgtol,eps0,epssil,epsox, >*/
  298. /*<      2   pivtol,pivrel >*/
  299. /* spice version 2g.6  sccsid=blank 3/15/83 */
  300. /*<       common /blank/ value(200000) >*/
  301. /*<       integer nodplc(64) >*/
  302. /*<       complex cvalue(32) >*/
  303. /*<       equivalence (value(1),nodplc(1),cvalue(1)) >*/
  304.  
  305. /*<       dimension adigit(10) >*/
  306. /*<       data adigit / 1h0,1h1,1h2,1h3,1h4,1h5,1h6,1h7,1h8,1h9 / >*/
  307. /*<       data ablnk,aper,aplus,aminus,astk / 1h , 1h., 1h+, 1h-, 1h* / >*/
  308. /*<       data bg,ak,au,an,ap,ae,am,af,at /1hg,1hk,1hu,1hn,1hp,1he,1hm, >*/
  309. /*<      1  1hf,1ht/ >*/
  310. /*<       data ai / 1hi / >*/
  311. /*<       data alprn, arprn, aequal / 1h(, 1h), 1h= / >*/
  312. /*<       data aend / 4h.end / >*/
  313.  
  314. /*      note:  the value of the function *nxtchr* (used extensively in */
  315. /* this routine) is as follows: */
  316.  
  317. /*                    <0:  end-of-line */
  318. /*                    =0:  delimiter found */
  319. /*                    >0:  non-delimiter found */
  320.  
  321. /*<       numfld=0 >*/
  322.     numfld = 0;
  323. /*<       nofld=10 >*/
  324.     nofld = 10;
  325. /*<       go to 20 >*/
  326.     goto L20;
  327.  
  328. /*  read next card */
  329.  
  330. /*<    10 nofld=10 >*/
  331. L10:
  332.     nofld = 10;
  333. /*<       call getlin >*/
  334.     getlin_();
  335. /*<       if (keof.eq.0) go to 20 >*/
  336.     if (flags_1.keof == 0) {
  337.     goto L20;
  338.     }
  339. /* ...  error:  unexpected end-of-file condition on input */
  340. /*<    15 keof=1 >*/
  341. L15:
  342.     flags_1.keof = 1;
  343. /*<       nofld=1 >*/
  344.     nofld = 1;
  345. /*<       numfld=0 >*/
  346.     numfld = 0;
  347. /*<       igoof=1 >*/
  348.     flags_1.igoof = 1;
  349. /*<       write (iofile,16) >*/
  350.     io__25.ciunit = status_1.iofile;
  351.     s_wsfe(&io__25);
  352.     e_wsfe();
  353. /*<    16 format('0*error*:  .end card missing'/) >*/
  354. /*<       go to 1000 >*/
  355.     goto L1000;
  356.  
  357. /*  eliminate trailing blanks rapidly */
  358.  
  359. /*<    20 if (afield(nofld).ne.ablnk) go to 40 >*/
  360. L20:
  361.     if (line_1.afield[nofld - 1] != ablnk) {
  362.     goto L40;
  363.     }
  364. /*<       if (nofld.eq.1) go to 30 >*/
  365.     if (nofld == 1) {
  366.     goto L30;
  367.     }
  368. /*<       nofld=nofld-1 >*/
  369.     --nofld;
  370. /*<       go to 20 >*/
  371.     goto L20;
  372. /* ...  write blank card */
  373. /*<    30 write (iofile,31) >*/
  374. L30:
  375.     io__26.ciunit = status_1.iofile;
  376.     s_wsfe(&io__26);
  377.     e_wsfe();
  378. /*<    31 format(1x) >*/
  379. /*<       go to 10 >*/
  380.     goto L10;
  381. /* ...  copy the card to output listing */
  382. /*<    40 write (iofile,41) (afield(i),i=1,nofld) >*/
  383. L40:
  384.     io__27.ciunit = status_1.iofile;
  385.     s_wsfe(&io__27);
  386.     i_1 = nofld;
  387.     for (i = 1; i <= i_1; ++i) {
  388.     do_fio(&c__1, (char *)&line_1.afield[i - 1], (ftnlen)sizeof(
  389.         doublereal));
  390.     }
  391.     e_wsfe();
  392. /*<    41 format(1x,10a8) >*/
  393.  
  394. /*  initialization for new card */
  395.  
  396. /*<    45 kntrc=0 >*/
  397. /* L45: */
  398.     line_1.kntrc = 0;
  399. /*<       kntlim=min0(8*nofld,iwidth) >*/
  400. /* Computing MAX */
  401.     i_1 = nofld << 3;
  402.     line_1.kntlim = min(miscel_1.iwidth,i_1);
  403.  
  404. /*  fetch first non-delimiter (see routine *nxtchr* for list) */
  405.  
  406. /*<    50 if (nxtchr(0)) 600,50,60 >*/
  407. L50:
  408.     if ((i_1 = nxtchr_(&c__0)) < 0) {
  409.     goto L600;
  410.     } else if (i_1 == 0) {
  411.     goto L50;
  412.     } else {
  413.     goto L60;
  414.     }
  415. /* ...  check for comment (leading asterisk) */
  416. /*<    60 if (achar.eq.astk) go to 10 >*/
  417. L60:
  418.     if (line_1.achar == astk) {
  419.     goto L10;
  420.     }
  421. /*<       go to 100 >*/
  422.     goto L100;
  423.  
  424. /*  fetch next character */
  425.  
  426. /*<    70 if (nxtchr(0)) 600,80,100 >*/
  427. L70:
  428.     if ((i_1 = nxtchr_(&c__0)) < 0) {
  429.     goto L600;
  430.     } else if (i_1 == 0) {
  431.     goto L80;
  432.     } else {
  433.     goto L100;
  434.     }
  435.  
  436. /*  two consecutive delimiters imply numeric zero unless the delimiter */
  437. /*  is a blank or parenthesis. */
  438.  
  439. /*<    80 if (achar.eq.ablnk) go to 70 >*/
  440. L80:
  441.     if (line_1.achar == ablnk) {
  442.     goto L70;
  443.     }
  444. /*<       if (achar.eq.alprn) go to 70 >*/
  445.     if (line_1.achar == alprn) {
  446.     goto L70;
  447.     }
  448. /*<       if (achar.eq.arprn) go to 70 >*/
  449.     if (line_1.achar == arprn) {
  450.     goto L70;
  451.     }
  452. /*<       if (achar.eq.aequal) go to 70 >*/
  453.     if (line_1.achar == aequal) {
  454.     goto L70;
  455.     }
  456. /* ...  check for sufficient space in storage arrays */
  457. /*<       if (numfld.lt.insize-1) go to 90 >*/
  458.     if (numfld < tabinf_1.insize - 1) {
  459.     goto L90;
  460.     }
  461. /*<       call extmem(ifield,50) >*/
  462.     extmem_(&tabinf_1.ifield, &c__50);
  463. /*<       call extmem(icode,50) >*/
  464.     extmem_(&tabinf_1.icode, &c__50);
  465. /*<       call extmem(idelim,50) >*/
  466.     extmem_(&tabinf_1.idelim, &c__50);
  467. /*<       call extmem(icolum,50) >*/
  468.     extmem_(&tabinf_1.icolum, &c__50);
  469. /*<       insize=insize+50 >*/
  470.     tabinf_1.insize += 50;
  471. /*<    90 numfld=numfld+1 >*/
  472. L90:
  473.     ++numfld;
  474. /*<       value(ifield+numfld)=0.0d0 >*/
  475.     blank_1.value[tabinf_1.ifield + numfld - 1] = 0.;
  476. /*<       nodplc(icode+numfld)=0 >*/
  477.     nodplc[tabinf_1.icode + numfld - 1] = 0;
  478. /*<       value(idelim+numfld)=achar >*/
  479.     blank_1.value[tabinf_1.idelim + numfld - 1] = line_1.achar;
  480. /*<       nodplc(icolum+numfld)=kntrc >*/
  481.     nodplc[tabinf_1.icolum + numfld - 1] = line_1.kntrc;
  482. /*<       go to 70 >*/
  483.     goto L70;
  484.  
  485. /*  check for sufficient space in storage arrays */
  486.  
  487. /*<   100 if (numfld.lt.insize-1) go to 110 >*/
  488. L100:
  489.     if (numfld < tabinf_1.insize - 1) {
  490.     goto L110;
  491.     }
  492. /*<       call extmem(ifield,50) >*/
  493.     extmem_(&tabinf_1.ifield, &c__50);
  494. /*<       call extmem(icode,50) >*/
  495.     extmem_(&tabinf_1.icode, &c__50);
  496. /*<       call extmem(idelim,50) >*/
  497.     extmem_(&tabinf_1.idelim, &c__50);
  498. /*<       call extmem(icolum,50) >*/
  499.     extmem_(&tabinf_1.icolum, &c__50);
  500. /*<       insize=insize+50 >*/
  501.     tabinf_1.insize += 50;
  502.  
  503. /*  begin scan of next field */
  504.  
  505. /* ...  initialization */
  506. /*<   110 jdelim=0 >*/
  507. L110:
  508.     jdelim = 0;
  509. /*<       xsign=1.0d0 >*/
  510.     xsign = 1.;
  511. /*<       xmant=0.0d0 >*/
  512.     xmant = 0.;
  513. /*<       idec=0 >*/
  514.     idec = 0;
  515. /*<       iexp=0 >*/
  516.     iexp = 0;
  517. /* ...  check for leading plus or minus sign */
  518. /*<       if (achar.eq.aplus) go to 210 >*/
  519.     if (line_1.achar == aplus) {
  520.     goto L210;
  521.     }
  522. /*<       if (achar.eq.aminus) go to 200 >*/
  523.     if (line_1.achar == aminus) {
  524.     goto L200;
  525.     }
  526. /* ...  finish initialization */
  527. /*<       anam=ablnk >*/
  528.     anam = ablnk;
  529. /*<       kchr=1 >*/
  530.     kchr = 1;
  531. /* ...  an isolated period indicates that a continuation card follows */
  532. /*<       if (achar.ne.aper) go to 120 >*/
  533.     if (line_1.achar != aper) {
  534.     goto L120;
  535.     }
  536. /* ...  alter initialization slightly if leading period found */
  537. /*<       idec=1 >*/
  538.     idec = 1;
  539. /*<       iexp=-1 >*/
  540.     iexp = -1;
  541. /*<       anam=aper >*/
  542.     anam = aper;
  543. /*<       kchr=2 >*/
  544.     kchr = 2;
  545. /* ...  now take a look at the next character */
  546. /*<       if (nxtchr(0)) 10,10,120 >*/
  547.     if (nxtchr_(&c__0) <= 0) {
  548.     goto L10;
  549.     } else {
  550.     goto L120;
  551.     }
  552.  
  553. /*  test for number (any digit) */
  554.  
  555. /*<   120 do 130 i=1,10 >*/
  556. L120:
  557.     for (i = 1; i <= 10; ++i) {
  558. /*<       if (achar.ne.adigit(i)) go to 130 >*/
  559.     if (line_1.achar != adigit[i - 1]) {
  560.         goto L130;
  561.     }
  562. /*<       xmant=dble(i-1) >*/
  563.     xmant = (doublereal) (i - 1);
  564. /*<       go to 210 >*/
  565.     goto L210;
  566. /*<   130 continue >*/
  567. L130:
  568.     ;}
  569.  
  570. /*  assemble name */
  571.  
  572. /*<       numfld=numfld+1 >*/
  573.     ++numfld;
  574. /*<       call move(anam,kchr,achar,1,1) >*/
  575.     move_(&anam, &kchr, &line_1.achar, &c__1, &c__1);
  576. /*<       kchr=kchr+1 >*/
  577.     ++kchr;
  578. /*<       do 150 i=kchr,8 >*/
  579.     for (i = kchr; i <= 8; ++i) {
  580. /*<       if (nxtchr(0)) 160,160,140 >*/
  581.     if (nxtchr_(&c__0) <= 0) {
  582.         goto L160;
  583.     } else {
  584.         goto L140;
  585.     }
  586. /*<   140 call move(anam,i,achar,1,1) >*/
  587. L140:
  588.     move_(&anam, &i, &line_1.achar, &c__1, &c__1);
  589. /*<   150 continue >*/
  590. /* L150: */
  591.     }
  592. /*<       go to 170 >*/
  593.     goto L170;
  594. /*<   160 jdelim=1 >*/
  595. L160:
  596.     jdelim = 1;
  597. /*<   170 value(ifield+numfld)=anam >*/
  598. L170:
  599.     blank_1.value[tabinf_1.ifield + numfld - 1] = anam;
  600. /*<       nodplc(icode+numfld)=1 >*/
  601.     nodplc[tabinf_1.icode + numfld - 1] = 1;
  602. /*<       nodplc(icolum+numfld)=kntrc >*/
  603.     nodplc[tabinf_1.icolum + numfld - 1] = line_1.kntrc;
  604. /* ...  no '+' format continuation possible for .end card */
  605. /*<       if (numfld.ge.2) go to 400 >*/
  606.     if (numfld >= 2) {
  607.     goto L400;
  608.     }
  609. /*<       if (anam.ne.aend) go to 400 >*/
  610.     if (anam != aend) {
  611.     goto L400;
  612.     }
  613. /*<       nodplc(icode+numfld+1)=-1 >*/
  614.     nodplc[tabinf_1.icode + numfld] = -1;
  615. /*<       go to 1000 >*/
  616.     goto L1000;
  617.  
  618. /*  process number */
  619.  
  620. /* ...  take note of leading minus sign */
  621. /*<   200 xsign=-1.0d0 >*/
  622. L200:
  623.     xsign = -1.;
  624. /* ...  take a look at the next character */
  625. /*<   210 if (nxtchr(0)) 335,335,220 >*/
  626. L210:
  627.     if (nxtchr_(&c__0) <= 0) {
  628.     goto L335;
  629.     } else {
  630.     goto L220;
  631.     }
  632. /* ...  test for digit */
  633. /*<   220 do 230 i=1,10 >*/
  634. L220:
  635.     for (i = 1; i <= 10; ++i) {
  636. /*<       if (achar.ne.adigit(i)) go to 230 >*/
  637.     if (line_1.achar != adigit[i - 1]) {
  638.         goto L230;
  639.     }
  640. /*<       xmant=xmant*10.0d0+dble(i-1) >*/
  641.     xmant = xmant * 10. + (doublereal) (i - 1);
  642. /*<       if (idec.eq.0) go to 210 >*/
  643.     if (idec == 0) {
  644.         goto L210;
  645.     }
  646. /*<       iexp=iexp-1 >*/
  647.     --iexp;
  648. /*<       go to 210 >*/
  649.     goto L210;
  650. /*<   230 continue >*/
  651. L230:
  652.     ;}
  653.  
  654. /*  check for decimal point */
  655.  
  656. /*<       if (achar.ne.aper) go to 240 >*/
  657.     if (line_1.achar != aper) {
  658.     goto L240;
  659.     }
  660. /* ...  make certain that this is the first one found */
  661. /*<       if (idec.ne.0) go to 500 >*/
  662.     if (idec != 0) {
  663.     goto L500;
  664.     }
  665. /*<       idec=1 >*/
  666.     idec = 1;
  667. /*<       go to 210 >*/
  668.     goto L210;
  669.  
  670. /*  test for exponent */
  671.  
  672. /*<   240 if (achar.ne.ae) go to 300 >*/
  673. L240:
  674.     if (line_1.achar != ae) {
  675.     goto L300;
  676.     }
  677. /*<       if (nxtchr(0)) 335,335,250 >*/
  678.     if (nxtchr_(&c__0) <= 0) {
  679.     goto L335;
  680.     } else {
  681.     goto L250;
  682.     }
  683. /*<   250 itemp=0 >*/
  684. L250:
  685.     itemp = 0;
  686. /*<       isign=1 >*/
  687.     isign = 1;
  688. /* ...  check for possible leading sign on exponent */
  689. /*<       if (achar.eq.aplus) go to 260 >*/
  690.     if (line_1.achar == aplus) {
  691.     goto L260;
  692.     }
  693. /*<       if (achar.ne.aminus) go to 270 >*/
  694.     if (line_1.achar != aminus) {
  695.     goto L270;
  696.     }
  697. /*<       isign=-1 >*/
  698.     isign = -1;
  699. /*<   260 if (nxtchr(0)) 285,285,270 >*/
  700. L260:
  701.     if (nxtchr_(&c__0) <= 0) {
  702.     goto L285;
  703.     } else {
  704.     goto L270;
  705.     }
  706. /* ...  test for digit */
  707. /*<   270 do 280 i=1,10 >*/
  708. L270:
  709.     for (i = 1; i <= 10; ++i) {
  710. /*<       if (achar.ne.adigit(i)) go to 280 >*/
  711.     if (line_1.achar != adigit[i - 1]) {
  712.         goto L280;
  713.     }
  714. /*<       itemp=itemp*10+i-1 >*/
  715.     itemp = itemp * 10 + i - 1;
  716. /*<       go to 260 >*/
  717.     goto L260;
  718. /*<   280 continue >*/
  719. L280:
  720.     ;}
  721. /*<       go to 290 >*/
  722.     goto L290;
  723. /*<   285 jdelim=1 >*/
  724. L285:
  725.     jdelim = 1;
  726. /* ...  correct internal exponent */
  727. /*<   290 iexp=iexp+isign*itemp >*/
  728. L290:
  729.     iexp += isign * itemp;
  730. /*<       go to 340 >*/
  731.     goto L340;
  732.  
  733. /*  test for scale factor */
  734.  
  735. /*<   300 if (achar.ne.am) go to 330 >*/
  736. L300:
  737.     if (line_1.achar != am) {
  738.     goto L330;
  739.     }
  740. /* ...  special check for *me* (as distinguished from *m*) */
  741. /*<       if (nxtchr(0)) 320,320,310 >*/
  742.     if (nxtchr_(&c__0) <= 0) {
  743.     goto L320;
  744.     } else {
  745.     goto L310;
  746.     }
  747. /*<   310 if (achar.ne.ae) go to 315 >*/
  748. L310:
  749.     if (line_1.achar != ae) {
  750.     goto L315;
  751.     }
  752. /*<       iexp=iexp+6 >*/
  753.     iexp += 6;
  754. /*<       go to 340 >*/
  755.     goto L340;
  756. /*<   315 if (achar.ne.ai) go to 325 >*/
  757. L315:
  758.     if (line_1.achar != ai) {
  759.     goto L325;
  760.     }
  761. /*<       xmant=xmant*25.4d-6 >*/
  762.     xmant *= 2.54e-5;
  763. /*<       go to 340 >*/
  764.     goto L340;
  765. /*<   320 jdelim=1 >*/
  766. L320:
  767.     jdelim = 1;
  768. /*<   325 iexp=iexp-3 >*/
  769. L325:
  770.     iexp += -3;
  771. /*<       go to 340 >*/
  772.     goto L340;
  773. /*<   330 if (achar.eq.at) iexp=iexp+12 >*/
  774. L330:
  775.     if (line_1.achar == at) {
  776.     iexp += 12;
  777.     }
  778. /*<       if (achar.eq.bg) iexp=iexp+9 >*/
  779.     if (line_1.achar == bg) {
  780.     iexp += 9;
  781.     }
  782. /*<       if (achar.eq.ak) iexp=iexp+3 >*/
  783.     if (line_1.achar == ak) {
  784.     iexp += 3;
  785.     }
  786. /*<       if (achar.eq.au) iexp=iexp-6 >*/
  787.     if (line_1.achar == au) {
  788.     iexp += -6;
  789.     }
  790. /*<       if (achar.eq.an) iexp=iexp-9 >*/
  791.     if (line_1.achar == an) {
  792.     iexp += -9;
  793.     }
  794. /*<       if (achar.eq.ap) iexp=iexp-12 >*/
  795.     if (line_1.achar == ap) {
  796.     iexp += -12;
  797.     }
  798. /*<       if (achar.eq.af) iexp=iexp-15 >*/
  799.     if (line_1.achar == af) {
  800.     iexp += -15;
  801.     }
  802. /*<       go to 340 >*/
  803.     goto L340;
  804. /*<   335 jdelim=1 >*/
  805. L335:
  806.     jdelim = 1;
  807.  
  808. /*  assemble the final number */
  809.  
  810. /*<   340 if (xmant.eq.0.0d0) go to 350 >*/
  811. L340:
  812.     if (xmant == 0.) {
  813.     goto L350;
  814.     }
  815. /*<       if (iexp.eq.0) go to 350 >*/
  816.     if (iexp == 0) {
  817.     goto L350;
  818.     }
  819. /*<       if (iabs(iexp).ge.201) go to 500 >*/
  820.     if (abs(iexp) >= 201) {
  821.     goto L500;
  822.     }
  823. /*<       xmant=xmant*dexp(dble(iexp)*xlog10) >*/
  824.     xmant *= exp((doublereal) iexp * knstnt_1.xlog10);
  825. /*<       if (xmant.gt.1.0d+35) go to 500 >*/
  826.     if (xmant > 1e35) {
  827.     goto L500;
  828.     }
  829. /*<       if (xmant.lt.1.0d-35) go to 500 >*/
  830.     if (xmant < 1e-35) {
  831.     goto L500;
  832.     }
  833. /*<   350 numfld=numfld+1 >*/
  834. L350:
  835.     ++numfld;
  836. /*<       value(ifield+numfld)=dsign(xmant,xsign) >*/
  837.     blank_1.value[tabinf_1.ifield + numfld - 1] = d_sign(&xmant, &xsign);
  838. /*<       nodplc(icode+numfld)=0 >*/
  839.     nodplc[tabinf_1.icode + numfld - 1] = 0;
  840. /*<       nodplc(icolum+numfld)=kntrc >*/
  841.     nodplc[tabinf_1.icolum + numfld - 1] = line_1.kntrc;
  842.  
  843. /*  skip to non-blank delimiter (if necessary) */
  844.  
  845. /*<   400 if (jdelim.eq.0) go to 440 >*/
  846. L400:
  847.     if (jdelim == 0) {
  848.     goto L440;
  849.     }
  850. /*<   410 value(idelim+numfld)=achar >*/
  851. L410:
  852.     blank_1.value[tabinf_1.idelim + numfld - 1] = line_1.achar;
  853. /*<       if (achar.ne.ablnk) go to 70 >*/
  854.     if (line_1.achar != ablnk) {
  855.     goto L70;
  856.     }
  857. /*<       if (nxtchr(0)) 450,410,420 >*/
  858.     if ((i_1 = nxtchr_(&c__0)) < 0) {
  859.     goto L450;
  860.     } else if (i_1 == 0) {
  861.     goto L410;
  862.     } else {
  863.     goto L420;
  864.     }
  865. /*<   420 kntrc=kntrc-1 >*/
  866. L420:
  867.     --line_1.kntrc;
  868. /*<       go to 70 >*/
  869.     goto L70;
  870. /*<   440 if (nxtchr(0)) 450,410,440 >*/
  871. L440:
  872.     if ((i_1 = nxtchr_(&c__0)) < 0) {
  873.     goto L450;
  874.     } else if (i_1 == 0) {
  875.     goto L410;
  876.     } else {
  877.     goto L440;
  878.     }
  879. /*<   450 value(idelim+numfld)=achar >*/
  880. L450:
  881.     blank_1.value[tabinf_1.idelim + numfld - 1] = line_1.achar;
  882. /*<       go to 600 >*/
  883.     goto L600;
  884.  
  885. /*  errors */
  886.  
  887. /*<   500 write (iofile,501) kntrc >*/
  888. L500:
  889.     io__38.ciunit = status_1.iofile;
  890.     s_wsfe(&io__38);
  891.     do_fio(&c__1, (char *)&line_1.kntrc, (ftnlen)sizeof(integer));
  892.     e_wsfe();
  893. /*<   501 format('0*error*:  illegal number -- scan stopped at column ',i3/) >*/
  894. /*<       igoof=1 >*/
  895.     flags_1.igoof = 1;
  896. /*<       numfld=numfld+1 >*/
  897.     ++numfld;
  898. /*<       value(ifield+numfld)=0.0d0 >*/
  899.     blank_1.value[tabinf_1.ifield + numfld - 1] = 0.;
  900. /*<       nodplc(icode+numfld)=0 >*/
  901.     nodplc[tabinf_1.icode + numfld - 1] = 0;
  902. /*<       value(idelim+numfld)=achar >*/
  903.     blank_1.value[tabinf_1.idelim + numfld - 1] = line_1.achar;
  904. /*<       nodplc(icolum+numfld)=kntrc >*/
  905.     nodplc[tabinf_1.icolum + numfld - 1] = line_1.kntrc;
  906.  
  907. /*  finished */
  908.  
  909. /*<   600 nodplc(icode+numfld+1)=-1 >*/
  910. L600:
  911.     nodplc[tabinf_1.icode + numfld] = -1;
  912.  
  913. /*  check next line for possible continuation */
  914.  
  915. /*<   610 call getlin >*/
  916. L610:
  917.     getlin_();
  918. /*<       if (keof.eq.1) go to 15 >*/
  919.     if (flags_1.keof == 1) {
  920.     goto L15;
  921.     }
  922. /*<       nofld=10 >*/
  923.     nofld = 10;
  924. /*<   620 if (afield(nofld).ne.ablnk) go to 630 >*/
  925. L620:
  926.     if (line_1.afield[nofld - 1] != ablnk) {
  927.     goto L630;
  928.     }
  929. /*<       if (nofld.eq.1) go to 650 >*/
  930.     if (nofld == 1) {
  931.     goto L650;
  932.     }
  933. /*<       nofld=nofld-1 >*/
  934.     --nofld;
  935. /*<       go to 620 >*/
  936.     goto L620;
  937. /*<   630 kntrc=0 >*/
  938. L630:
  939.     line_1.kntrc = 0;
  940. /*<       kntlim=min0(8*nofld,iwidth) >*/
  941. /* Computing MAX */
  942.     i_1 = nofld << 3;
  943.     line_1.kntlim = min(miscel_1.iwidth,i_1);
  944. /* ...  continuation line has a '+' as first non-delimiter on card */
  945. /*<   632 if(nxtchr(0)) 650,632,634 >*/
  946. L632:
  947.     if ((i_1 = nxtchr_(&c__0)) < 0) {
  948.     goto L650;
  949.     } else if (i_1 == 0) {
  950.     goto L632;
  951.     } else {
  952.     goto L634;
  953.     }
  954. /*<   634 if(achar.ne.aplus) go to 640 >*/
  955. L634:
  956.     if (line_1.achar != aplus) {
  957.     goto L640;
  958.     }
  959. /*<       write(iofile,41) (afield(i),i=1,nofld) >*/
  960.     io__39.ciunit = status_1.iofile;
  961.     s_wsfe(&io__39);
  962.     i_1 = nofld;
  963.     for (i = 1; i <= i_1; ++i) {
  964.     do_fio(&c__1, (char *)&line_1.afield[i - 1], (ftnlen)sizeof(
  965.         doublereal));
  966.     }
  967.     e_wsfe();
  968. /*<       go to 70 >*/
  969.     goto L70;
  970. /*<   640 if (achar.ne.astk) go to 1000 >*/
  971. L640:
  972.     if (line_1.achar != astk) {
  973.     goto L1000;
  974.     }
  975. /*<   650 write (iofile,41) (afield(i),i=1,nofld) >*/
  976. L650:
  977.     io__40.ciunit = status_1.iofile;
  978.     s_wsfe(&io__40);
  979.     i_1 = nofld;
  980.     for (i = 1; i <= i_1; ++i) {
  981.     do_fio(&c__1, (char *)&line_1.afield[i - 1], (ftnlen)sizeof(
  982.         doublereal));
  983.     }
  984.     e_wsfe();
  985. /*<       go to 610 >*/
  986.     goto L610;
  987. /*<  1000 return >*/
  988. L1000:
  989.     return 0;
  990. /*<       end >*/
  991. } /* card_ */
  992.  
  993. #undef cvalue
  994. #undef nodplc
  995. #undef bg
  996. #undef astk
  997. #undef aminus
  998. #undef aplus
  999. #undef aper
  1000. #undef ablnk
  1001. #undef adigit
  1002. #undef aend
  1003. #undef aequal
  1004. #undef arprn
  1005. #undef alprn
  1006. #undef ai
  1007. #undef at
  1008. #undef af
  1009. #undef am
  1010. #undef ae
  1011. #undef ap
  1012. #undef an
  1013. #undef au
  1014. #undef ak
  1015.  
  1016.  
  1017.